home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / sc2.scm < prev    next >
Text File  |  1999-04-19  |  2KB  |  67 lines
  1. ;"sc2.scm" Implementation of rev2 procedures eliminated in subsequent versions.
  2. ; Copyright (C) 1991, 1993 Aubrey Jaffer.
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (define (substring-move-left! string1 start1 end1 string2 start2)
  21.   (do ((i start1 (+ i 1))
  22.        (j start2 (+ j 1))
  23.        (l (- end1 start1) (- l 1)))
  24.       ((<= l 0))
  25.     (string-set! string2 j (string-ref string1 i))))
  26.  
  27. (define (substring-move-right! string1 start1 end1 string2 start2)
  28.   (do ((i (+ start1 (- end1 start1) -1) (- i 1))
  29.        (j (+ start2 (- end1 start1) -1) (- j 1))
  30.        (l (- end1 start1) (- l 1)))
  31.       ((<= l 0))
  32.     (string-set! string2 j (string-ref string1 i))))
  33.  
  34. (define (substring-fill! string start end char)
  35.   (do ((i start (+ i 1))
  36.        (l (- end start) (- l 1)))
  37.       ((<= l 0))
  38.     (string-set! string i char)))
  39.  
  40. (define (string-null? str)
  41.   (= 0 (string-length str)))
  42.  
  43. (define append!
  44.   (lambda args
  45.     (cond ((null? args) '())
  46.       ((null? (cdr args)) (car args))
  47.       ((null? (car args)) (apply append! (cdr args)))
  48.       (else
  49.        (set-cdr! (last-pair (car args))
  50.              (apply append! (cdr args)))
  51.        (car args)))))
  52.  
  53. ;;;; need to add code for OBJECT-HASH and OBJECT-UNHASH
  54.  
  55. (define 1+
  56.   (let ((+ +))
  57.     (lambda (n) (+ n 1))))
  58. (define -1+
  59.   (let ((+ +))
  60.     (lambda (n) (+ n -1))))
  61.  
  62. (define <? <)
  63. (define <=? <=)
  64. (define =? =)
  65. (define >? >)
  66. (define >=? >=)
  67.